home *** CD-ROM | disk | FTP | other *** search
/ User's Choice Windows CD / User's Choice Windows CD (CMS Software)(1993).iso / win_u_z / uc12.zip / CLIPOBJ.PAS < prev    next >
Pascal/Delphi Source File  |  1992-08-25  |  20KB  |  833 lines
  1. UNIT ClipObj;
  2. Interface
  3. USES WinTypes, WinProcs, WObjects, Strings,Win31;
  4. {$D Copyright (c) 1992 Doug Overmyer}
  5. const
  6.     st_OK = 1;
  7.   st_ClipFailure = 2;
  8.   st_NoMem = 3;
  9. type
  10.  
  11. PClipItem = ^TClipItem;
  12. TClipItem = object(TObject)
  13.     CHandle:THandle;
  14.   CName:PChar;
  15.   CFormat:Word;
  16.   constructor Init(NewCHandle:THandle;NewCName:PChar;NewCFormat:Word);
  17.   destructor Done;virtual;
  18. end;
  19.  
  20. PClipC = ^TClipC;
  21. TClipC = object(TCollection)
  22.     constructor Init(ALimit,ADelta:Integer);
  23.   destructor Done;virtual;
  24. end;
  25.  
  26. PClipObj = ^TClipObj;
  27. TClipObj = OBJECT(TObject)
  28.     constructor Init(hW:HWnd;var Stat:Word;SRect:TRect);
  29.   procedure GetClip(hW : hWnd; var Stat : Word);
  30.   destructor Done; Virtual;
  31.   procedure CopyClip(hW : hWnd);
  32.   procedure RenderSelf(DC:hDC;hWin:HWnd);
  33.   procedure RedrawSelf(DC:hDC;hWin:HWnd);
  34.   function GetStatus          : Word;
  35.     function GetPal             : hPalette;
  36.     function GetDIB                            : THandle;
  37.   function GetPICT            : THandle;
  38.   procedure GetInfo(Info:PChar;Len:Integer);
  39.   procedure SetIsPrefText(Choice:Bool);
  40.   procedure ToggleIsPrefText;
  41.   procedure GetFormats(Buf:PChar);
  42. Private
  43.   Clips    : PClipC;
  44.     name       : ARRAY[0..80] OF Char;
  45.   hDIB         : THandle;
  46.   hPal     : hPalette;
  47.   hPICT    : THandle;
  48.   hText    :THandle;
  49.   hNative  :THandle;
  50.   hBMP     :HBitmap;
  51.   hDisp    : HBitmap;
  52.   Status   :Word;
  53.   IsPrefText :Bool;
  54.   SR       : TRect;  {Sizing Rectangle}
  55. end;
  56. {****************************  Implementation  **********************}
  57. Implementation
  58. type
  59.   LongType = record
  60.     CASE Word OF
  61.       0: (Ptr: Pointer);
  62.       1: (Long: Longint);
  63.       2: (Lo: Word;
  64.        Hi: Word);
  65.   end;
  66. procedure AHIncr; far; external 'KERNEL' index 114;
  67. function _hRead(hFile:Integer;Buffer:PChar;dwBytes:LongInt):LongInt;far; external 'KERNEL';
  68. function _hWrite(hFile:Integer;Buffer:PChar;dwBytes:LongInt):LongInt;far; external 'KERNEL';
  69. {************************* Functions  *******************************}
  70. function LongMin(A, B: LongInt): LongInt;
  71. begin
  72.   if A < B then LongMin := A else LongMin := B;
  73. end;
  74.  
  75. function LongMax(A, B: LongInt): LongInt;
  76. begin
  77.   if A > B then LongMax := A else LongMax := B;
  78. end;
  79.  
  80. function DIBSize(Width,Height:LongInt;Res:Integer):LongInt;
  81. begin
  82.     DIBSize := (((LongInt(Width)*RES+31) div 32) * 4) * Height;
  83. end;
  84.  
  85. function CopyGHND(hGM1:THandle):THandle;
  86. var
  87.   Size:LongInt;
  88.   hGM:THandle;
  89.   pGM,pGM1:Pointer;
  90. begin
  91.     CopyGHND := 0;
  92.   Size :=GlobalSize(hGM1);
  93.   pGM1 := GlobalLock(hGM1);
  94.   IF pGM1 = NIL then Exit;
  95.   hGM :=GlobalAlloc(GHND,Size);
  96.   pGM := GlobalLock(hGM);
  97.   if pGM <> nil then
  98.       hmemCpy(pGM,pGM1,Size);
  99.   GlobalUnlock(hGM);
  100.   CopyGHND := hGM;
  101. end;
  102.  
  103. function GetDIBColorCnt(bi:PBitmapInfo):Word;
  104. begin
  105.   GetDIBColorCnt := bi^.bmiHeader.biClrUsed;
  106.   if bi^.bmiHeader.biClrUsed = 0 then
  107.         if bi^.bmiHeader.biBitCount <> 24 then
  108.             GetDIBColorCnt:= 1 shl bi^.bmiHeader.biBitCount;
  109. end;
  110.  
  111. function GetDIBBits(pDIB:Pointer):Pointer;
  112. var
  113.     bi:PBitmapInfo;
  114.     cPalColors:Word;
  115. begin
  116.     GetDIBBits := NIL;
  117.   bi := pDIB;
  118.   cPalColors := GetDIBColorCnt(bi);
  119.   GetDIBBits := Ptr(Seg(bi^),
  120.     ofs(bi^)+sizeof(TBitmapInfoHeader)+cPalColors*sizeof(TRGBQuad));
  121. end;
  122.  
  123. function GetDIBPal(bi:PBitmapInfo):HPalette;
  124. var
  125.     PalSize,N,cPalColors: Word;
  126.     pal : PLogPalette;
  127. begin
  128.     GetDIBPal := 0;
  129.     cPalColors :=GetDIBColorCnt(bi);
  130.     IF cPalColors = 0 then Exit;
  131.   PalSize := SizeOf(TLogPalette)+Pred(cPalColors)*sizeof(TPaletteEntry);
  132.   GetMem(pal, PalSize);
  133.   pal^.palVersion := $300;
  134.   pal^.palNumEntries := cPalColors;
  135.   FillChar(pal^.palPalEntry, cPalColors *sizeof(TPaletteEntry), 0);
  136.   FOR N := 0 TO pred(cPalColors) DO
  137.      WITH pal^.palPalEntry[N], bi^.bmiColors[N] DO
  138.        begin
  139.        peRed   := rgbRed;
  140.        peGreen := rgbGreen;
  141.        peBlue  := rgbBlue
  142.        end;
  143.   GetDibPal := CreatePalette(pal^);
  144.   FreeMem(pal, PalSize);
  145. end;
  146.  
  147. function CopyPal(hP:hPalette):hPalette;
  148. var
  149.  Pal : PLogPalette;
  150.  cPalColors:Word;
  151. begin
  152.   CopyPal := 0;
  153.   if hP = 0 then Exit;
  154.   GetObject(hP,2,@cPalColors);
  155.   GetMem(Pal, sizeof(TLogPalette) + pred(cPalColors)*sizeof(TPaletteEntry));
  156.   pal^.palVersion := $300;
  157.   pal^.palNumEntries := cPalColors;
  158.   GetPaletteEntries(hP, 0, cPalColors,pal^.palPalEntry);
  159.   CopyPal := CreatePalette(pal^);
  160.   FreeMem(Pal, sizeof(TLogPalette)+pred(cPalColors)*sizeof(TPaletteEntry));
  161. end;
  162.  
  163. function CopyBMP(hB1:HBitmap;DC:hDC): hBitmap;
  164. var
  165.     cBits,ret:LongInt;
  166.   Bits:THandle;
  167.   pBits:Pointer;
  168.   tb:TBitmap;
  169.   hB2:HBitmap;
  170. begin
  171.     CopyBMP := 0;
  172.   if hB1 = 0 then Exit;
  173.   GetObject(hB1,sizeof(TBitmap),@tb);
  174.   cBits := LongInt(tb.bmWidthBytes)*tb.bmHeight *tb.bmPlanes;
  175.   bits :=GlobalAlloc(GHND,cBits);
  176.   pBits := GlobalLock(Bits);
  177.   ret :=GetBitmapBits(hB1,cBits,pBits);
  178.   hB2 := CreateCompatibleBitmap(DC,tb.bmWidth,tb.bmHeight);
  179.   ret :=SetBitmapBits(hB2,cBits,pBits);
  180.   GlobalUnlock(Bits);
  181.   GlobalFree(Bits);
  182.   CopyBMP := hB2;
  183. end;
  184.  
  185. function ScaleBMP(hB1:HBitmap;hP:HPalette;DC:hDC;SR:TRect): hBitmap;
  186. var
  187.     cBits,ret:LongInt;
  188.   Bits:THandle;
  189.   pBits:Pointer;
  190.   tb:TBitmap;
  191.   hB2,oB1,oB2:HBitmap;
  192.   RC:TRect;
  193.   MaxXY,X,Y:LongInt;
  194.   MemDC1,MemDC2:HDC;
  195.   oP:HPalette;
  196. begin
  197.     ScaleBMP := 0;
  198.   if hB1 = 0 then Exit;
  199.   GetObject(hB1,sizeof(TBitmap),@tb);
  200.   X:=tb.bmWidth;Y:=tb.bmHeight;
  201.     if X > Y then MaxXY :=X    else MaxXY:=Y;
  202.   SetRect(RC,0,0,SR.Right*X div MaxXY,
  203.         SR.Bottom*Y div MaxXY);
  204.   MemDC1:= CreateCompatibleDC(DC);
  205.   MemDC2:= CreateCompatibleDC(DC);
  206.   hB2:=CreateCompatibleBitmap(DC,RC.Right,RC.Bottom);
  207.   oB2:=SelectObject(MemDC2,hB2);
  208.   oB1:=SelectObject(MemDC1,hB1);
  209.   if hP > 0 then oP := SelectPalette(memDC2,hP,False); 
  210.   RealizePalette(memDC2);           
  211.   SetStretchBltMode(memDC2,stretch_deletescans);
  212.   StretchBlt(memDC2,0,0,RC.Right,RC.Bottom,memDC1,0,0,
  213.         X,Y,SRCCopy);
  214.   if hP > 0 then SelectPalette(memDC2,oP,False);  
  215.   SelectObject(memDC1,oB1);
  216.   SelectObject(memDC2,oB2);
  217.   DeleteDC(memDC1);
  218.   DeleteDC(memDC2);
  219.   ScaleBMP :=hB2;
  220. end;
  221.  
  222. function BMPtoDIB(hB:HBitmap;hP:HPalette;DC:HDC):THandle;
  223. var
  224.     hbi:THandle;
  225.     bi:PBitmapInfo;
  226.   tb:TBitmap;
  227.   pBits:Pointer;
  228.   hBits:THandle;
  229.   cSize:LongInt;
  230.   op:HPalette;
  231.   bRES,cColor:Integer;
  232. begin
  233.     if hP <> 0 then
  234.       begin
  235.     op :=SelectPalette(DC,hP,false);
  236.     RealizePalette(DC);
  237.     end
  238.     else op := 0;
  239.     GetObject(hB,sizeof(TBitmap),@tb);
  240.   bRES := tb.bmPlanes*tb.bmBitsPixel;
  241.   cColor := 0;
  242.   if bRES < 24 then cColor := 1 shl bRES;
  243.   cSize :=DIBSize(tb.bmWidth,tb.bmHeight,bRes);
  244.   hbi :=GlobalAlloc(GHND,sizeof(TBitmapInfoHeader)+cColor*sizeof(TRGBQuad)+cSize);
  245.   bi := GlobalLock(hbi);
  246.   with bi^.bmiHeader do
  247.       begin
  248.         biSize:= sizeof(TBitmapInfoHeader);
  249.       biWidth :=tb.bmWidth;
  250.       biHeight := tb.bmHeight;
  251.     biPlanes := 1;
  252.     biBitCount := bRES;
  253.     biCompression := BI_RGB;
  254.     end;
  255.   pBits:=Ptr(Seg(bi^),
  256.         ofs(bi^)+sizeof(TBitmapInfoHeader)+cColor*sizeof(TRGBQuad));
  257.   GetDIBits(DC,hB,0,tb.bmHeight,pBits,bi^,DIB_RGB_Colors);
  258.   GlobalUnlock(hbi);
  259.   BMPtoDIB := hbi;
  260.   if hP > 0 then selectPalette(DC,op,false);
  261. end;
  262.  
  263. function DIBtoBMP(H:THandle;hW:HWnd    ):hBitmap;
  264. var
  265.     bi:PBitmapInfo;
  266.   hP,oP:HPalette;
  267.   bits:Pointer;
  268.   DC:hDC;
  269. begin
  270.     DIBtoBMP := 0;
  271.   if H = 0 then Exit;
  272.   bi := GlobalLock(H);
  273.   if bi = nil then Exit;
  274.   hP := GetDibPal(bi);
  275.   DC := GetDC(hW);
  276.   if hP > 0 then oP := SelectPalette(DC,hP,False);
  277.   RealizePalette(DC);
  278.   bits := GetDIBBits(bi);
  279.   DIBtoBMP:= CreateDIBitmap(DC, bi^.bmiHeader,
  280.         cbm_Init, bits, bi^, dib_RGB_Colors);
  281.   GlobalUnlock(H);
  282.   if hP > 0 then SelectPalette(DC,oP,False);
  283.   DeleteObject(hP);
  284.   ReleaseDC(hW,DC);
  285. end;
  286.  
  287. function DIBtoBMPScaled(H:THandle;hW:HWnd;SR:TRect):hBitmap;
  288. var
  289.     bi:PBitmapInfo;
  290.   hP,oP:HPalette;
  291.   bits:Pointer;
  292.   DC:hDC;
  293.   hB,oB:HBitmap;
  294.   RC:TRect;
  295.   MaxXY,X,Y:Word;
  296.   MemDC:HDC;
  297. begin
  298.     hP:= 0;
  299.     DIBtoBMPScaled := 0;
  300.   if H = 0 then Exit;
  301.   bi := GlobalLock(H);
  302.   if bi = nil then Exit;
  303.   X:=bi^.bmiheader.biWidth;Y:=bi^.bmiheader.biHeight;
  304.     MaxXY:=LongMax(X,Y);
  305.   SetRect(RC,0,0,SR.Right * X div MaxXY,
  306.         SR.Bottom * Y div MaxXY);
  307.   hP := GetDibPal(bi); 
  308.   DC := GetDC(hW);
  309.   MemDC:= CreateCompatibleDC(DC);
  310.   hB:=CreateCompatibleBitmap(DC,RC.Right,RC.Bottom);
  311.   oB:=SelectObject(MemDC,hB);
  312.   if hP > 0 then oP := SelectPalette(memDC,hP,False); 
  313.   RealizePalette(memDC);             
  314.   bits := GetDIBBits(bi);
  315.   SetStretchBltMode(memDC,stretch_deletescans);
  316.   StretchDIBits(memDC,0,0,RC.Right,RC.Bottom,0,0,
  317.         X,Y,bits, bi^, dib_RGB_Colors,SRCCopy);
  318.   GlobalUnlock(H);
  319.   if hP > 0 then SelectPalette(memDC,oP,False);
  320.   if hP > 0 then DeleteObject(hP);
  321.   SelectObject(memDC,oB);
  322.   DeleteDC(memDC);
  323.   DIBtoBMPScaled :=hB;
  324.   ReleaseDC(hW,DC);
  325. end;
  326.  
  327. function CopyPICT(H:THandle):THandle;
  328. var
  329.     mi:PMetaFilePict;
  330.   hMFP:THandle;
  331.   pMFP:PMetaFilePict;
  332. begin
  333.     CopyPICT := 0;
  334.   mi := GlobalLock(H);
  335.   If mi = nil then EXIT;
  336.   hMFP := GlobalAlloc(GHND,sizeof(TMetaFilePict));
  337.   pMFP := GlobalLock(hMFP);
  338.   pMFP^.mm := mi^.mm;
  339.   pMFP^.xEXT := mi^.xEXT;
  340.   pMFP^.yEXT := mi^.yEXT;
  341.   pMFP^.hMF  := CopyMetaFile(mi^.hMF,nil);
  342.   GlobalUnlock(H);
  343.   GlobalUnlock(hMFP);
  344.   CopyPICT := hMFP;
  345. end;
  346.  
  347. procedure DelPICT(H:THandle);
  348. var
  349.   pMFP:PMetaFilePict;
  350. begin
  351.     if H = 0 then Exit;
  352.     pMFP := GlobalLock(H);
  353.   if pMFP = nil then Exit;
  354.   DeleteMetaFile(pMFP^.hMF);
  355.   GlobalUnlock(H);
  356.   GlobalFree(H);
  357. end;
  358.  
  359. procedure GetPICTSize(H:THandle;DC:HDC;HWin:HWnd;var X,Y:LongInt);
  360. var
  361.   om:Integer;
  362.   mfp:PMetaFilePict;
  363.   XP,YP:TPoint;
  364.   CR:TRect;
  365. begin
  366.     XP.X := 0;XP.Y:=0;YP.X:=0;YP.Y:= 0;
  367.   GetClientRect(HWin,CR);
  368.   if H = 0 then Exit;
  369.   mfp := GlobalLock(H);
  370.   if mfp = nil then Exit;
  371.   if (mfp^.mm = MM_ISOTROPIC) OR (mfp^.mm = MM_ANISOTROPIC) then
  372.       om := SetMapMode(DC,MM_HIMETRIC)
  373.     else
  374.         om := SetMapMode(DC,mfp^.mm);
  375.   XP.x := mfp^.xExt;
  376.     YP.y := mfp^.yExt;
  377.   SetViewportOrg(DC,0,0);
  378.   LPtoDP(DC,XP,1);LPtoDP(DC,YP,1);  {get nominal size of image}
  379.   SetMapMode(DC,om);
  380.   GlobalUnlock(H);
  381.      X:=abs(XP.x); Y:= abs(YP.Y);
  382.   if (X=0) or (Y=0) then
  383.       begin
  384.     X:=CR.Right;Y:=CR.Bottom;
  385.     end;
  386. end;
  387.  
  388. procedure RenderPICT(H:THandle;DC:HDC;HWin:HWnd;SR:TRect);
  389. var
  390.   om:Integer;
  391.   mfp:PMetaFilePict;
  392.   X,Y:LongInt;
  393.   MaxXY:LongInt;
  394. begin
  395.     if H = 0 then Exit;
  396.   X:=SR.Right;Y:=SR.Bottom;
  397.   MaxXY:=LongMax(X,Y);
  398.   mfp := GlobalLock(H);
  399.   om := SetMapMode(DC,mfp^.mm);
  400.   SetViewportOrg(DC,0,0);
  401.   SetViewPortExt(DC,X,Y);
  402.   PlayMetaFile(DC,mfp^.hMF);
  403.   GlobalUnlock(H);
  404.   SetMapMode(DC,oM);
  405. end;
  406.  
  407. function PICTtoBMP(H:THandle;DC:HDC;HWin:HWnd;SR:TRect):HBitmap;
  408. var
  409.     RC:TRect;
  410.   om:Integer;
  411.   hB,oB:HBitmap;
  412.   MemDC:hDC;
  413.   X,Y,Size:LongInt;
  414.   MaxXY:LongInt;
  415. begin
  416.     PICTtoBMP := 0;
  417.   if H = 0 then Exit;
  418.     GetPICTSize(H,DC,HWin,X,Y);
  419.   MaxXY:=LongMax(X,Y);
  420.   SetRect(RC,0,0,SR.Right * X div MaxXY,SR.Bottom * Y div MaxXY);
  421.   memDC := CreateCompatibleDC(DC);
  422.   hB := CreateCompatibleBitmap(DC,RC.Right,RC.Bottom);
  423.   oB:=SelectObject(memDC,hB);
  424.   FillRect(memDC,RC,GetStockObject(WHITE_BRUSH));
  425.   RenderPict(H,memDC,HWin,RC);
  426.   SelectObject(memDC,oB);
  427.   DeleteDC(memDC);
  428.   PICTtoBMP:= hB;
  429. end;
  430.  
  431. {*************************  TClipObj  *******************************}
  432. constructor TClipObj.Init(hW:hWnd;var Stat:Word;SRect:TRect);
  433. begin
  434.     TObject.Init;
  435.   SR:=SRect;
  436.   IsPrefText := True;
  437.     GetClip(hW,Stat);
  438.     if Stat  <> id_Ok then
  439.         Fail;
  440. end;
  441.  
  442. procedure TClipObj.GetClip(hW : hWnd;var Stat:Word);
  443. var
  444.     H      : THandle;
  445.   hB     : HBitmap;
  446.   DC     : hDC;
  447.   nF     :Word;
  448.   nN     :Array[0..50] of Char;
  449.   cF     :Integer;
  450.   nH     :THandle;
  451.   Indx   :Integer;
  452.   Clip   :PClipItem;
  453. begin
  454.     H := 0;hText := 0;hPal := 0;hDIB := 0;hPICT := 0;
  455.     hNative := 0;nF := 0;hBMP := 0;hDISP:=0;
  456.     Stat := st_ClipFailure;
  457.   if NOT OpenClipboard(hW) then EXIT;
  458.   Stat := st_OK;
  459.   Clips := New(PClipC,Init(10,10));
  460.   cF :=CountClipboardFormats;
  461.   for Indx := 0 to Pred(cF) do
  462.       begin
  463.       nF := EnumClipboardFormats(nF);
  464.       StrCopy(nN,'');
  465.     GetClipboardFormatName(nF,nN,50);
  466.       H := GetClipboardData(nF);
  467.     if H = 0 then
  468.             {ignore these, usually owner-draw}
  469.     else if (StrLIComp(nN,'MGX',3) = 0) then
  470.         {lets skip this SOB}
  471.         else
  472.         begin
  473.         case nF of
  474.             CF_DIB:
  475.           begin
  476.                 nH :=CopyGHND(H);
  477.           Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
  478.         hDIB := nH;
  479.           end;
  480.       CF_PALETTE:
  481.           begin
  482.         nH := CopyPal(H);
  483.           Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
  484.         hPAL := nH;
  485.           end;
  486.       CF_BITMAP:
  487.           begin
  488.         DC := GetDC(HW);
  489.         nH := CopyBMP(H,DC);
  490.           Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
  491.         ReleaseDC(hW,DC);
  492.         hBMP := nH;
  493.           end;
  494.       CF_METAFILEPICT:
  495.           begin
  496.         nH := CopyPICT(H);
  497.           Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
  498.         hPICT := nH;
  499.           end;
  500.       CF_TEXT:
  501.           begin
  502.         nH :=CopyGHND(H);
  503.           Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
  504.         hText:= nH;
  505.           end;
  506.       else
  507.           begin
  508.         nH :=CopyGHND(H);
  509.           Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
  510.         if StrIComp('Native',nN) = 0 then hNative := nH;
  511.           end;
  512.              end;
  513.       end;
  514.     end;
  515.   CloseClipboard;
  516.   if Stat = st_OK then    {Build graphic thumbnail}
  517.       begin
  518.       if (hDIB > 0) then
  519.         hDisp:=DIBtoBMPScaled(hDIB,hW,SR)
  520.       else if (hBMP>0) then
  521.           begin
  522.         DC:=GetDC(HW);
  523.           hDISP:=ScaleBMP(hBMP,hPAL,DC,SR);
  524.         releaseDC(HW,DC);
  525.         end
  526.       else if (hPict>0) then
  527.           begin
  528.         DC:=GetDC(HW);
  529.           hDISP:= PICTtoBMP(hPICT,DC,hW,SR);
  530.         releaseDC(HW,DC);
  531.         end;
  532.     end
  533.   else       {if failure, dealloc objects}
  534.       for Indx := 0 to Pred(Clips^.Count) do
  535.           begin
  536.             Clip := Clips^.At(Indx);
  537.         case Clip^.CFormat of
  538.           CF_PALETTE:
  539.                     DeleteObject(Clip^.CHandle);
  540.                 CF_BITMAP:
  541.               DeleteObject(Clip^.CHandle);
  542.           CF_METAFILEPICT:
  543.                     DelPICT(Clip^.CHandle);
  544.           else
  545.               GlobalFree(Clip^.CHandle);
  546.                  end;
  547.         end;
  548.   Status := Stat;
  549. end;
  550.  
  551. procedure TClipObj.CopyClip(hW : hWnd);
  552. var
  553.   DC : hDC;
  554.   oP : hPalette;
  555.   cSize : LongInt;
  556.   Clip:PClipItem;
  557.     nH:THandle;
  558.     Indx:Integer;
  559. begin
  560.   Status := st_ClipFailure;
  561.   if NOT OpenClipboard(hW) then EXIT;
  562.     EmptyClipboard;
  563.   for Indx := 0 to Pred(Clips^.Count) do
  564.       begin
  565.         Clip := Clips^.At(Indx);
  566.     case Clip^.CFormat of
  567.             CF_DIB:
  568.           begin
  569.                 nH :=CopyGHND(Clip^.CHandle);
  570.           SetClipboardData(Clip^.CFormat,nH);
  571.           end;
  572.       CF_PALETTE:
  573.           begin
  574.         nH := CopyPal(Clip^.CHandle);
  575.           SetClipboardData(Clip^.CFormat,nH);
  576.           end;
  577.       CF_BITMAP:
  578.           begin
  579.         DC := GetDC(HW);
  580.         if hPAL > 0 then oP:=SelectPalette(DC,hPAL,false);
  581.         RealizePalette(DC);
  582.         nH := CopyBMP(Clip^.CHandle,DC);
  583.         if hPAL > 0 then SelectPalette(DC,oP,false);
  584.           SetClipboardData(Clip^.CFormat,nH);
  585.         ReleaseDC(hW,DC);
  586.           end;
  587.       CF_METAFILEPICT:
  588.           begin
  589.         nH := CopyPICT(Clip^.CHandle);
  590.           SetClipboardData(Clip^.CFormat,nH);
  591.           end;
  592.       CF_TEXT:
  593.           begin
  594.         nH :=CopyGHND(Clip^.CHandle);
  595.           SetClipboardData(Clip^.CFormat,nH);
  596.           end;
  597.       else
  598.           begin
  599.         nH :=CopyGHND(Clip^.CHandle);
  600.           SetClipboardData(Clip^.CFormat,nH);
  601.           end;
  602.          end;
  603.     end;
  604.   CloseClipboard;
  605. end;
  606.  
  607. destructor TClipObj.Done;
  608. var
  609.     Indx:Integer;
  610.   Clip:PClipItem;
  611. begin
  612.   for Indx := 0 to Pred(Clips^.Count) do
  613.       begin
  614.         Clip := Clips^.At(Indx);
  615.     case Clip^.CFormat of
  616.             CF_DIB:
  617.                 GlobalFree(Clip^.CHandle);
  618.       CF_PALETTE:
  619.                 DeleteObject(Clip^.CHandle);
  620.             CF_BITMAP:
  621.           DeleteObject(Clip^.CHandle);
  622.       CF_METAFILEPICT:
  623.                 DelPICT(Clip^.CHandle);
  624.             CF_TEXT:
  625.           GlobalFree(Clip^.CHandle);
  626.       else
  627.           GlobalFree(Clip^.CHandle);
  628.          end;
  629.     end;
  630.   if hDisp >0 then DeleteObject(hDISP);
  631.     Dispose(Clips,Done);
  632.   TObject.Done;
  633. end;
  634.  
  635. procedure TClipObj.RenderSelf(DC:hDC;hWin:HWnd);
  636. var
  637.   oP:hPalette;
  638.   tb:TBitmap;
  639.   oB:HBitmap;
  640.   pBits:Pointer;
  641.   bi:PBitmapInfo;
  642.   pT:Pointer;
  643.   CR:TRect;
  644.   memDC:hDC;
  645. begin
  646.     if ((hText=0) and (hDisp=0)) then EXIT;
  647.     if ((hText > 0) and IsPrefText) or
  648.         (hDisp=0) then
  649.     begin
  650.     pT := GlobalLock(hText);
  651.     GetClientRect(hWin,CR);
  652.     SetBkMode(DC,transparent);
  653.     DrawText(DC,pT,-1,CR,DT_Left);
  654.     GlobalUnlock(hText);
  655.     end
  656.     else if hDISP > 0 then
  657.       begin
  658.         if hPal > 0 then oP := SelectPalette(DC,hPal,False);    
  659.       if hPal > 0 then RealizePalette(DC);
  660.       GetObject(hDISP,sizeof(TBitmap),@tb);
  661.     memDC:=CreateCompatibleDC(DC);
  662.     oB:=SelectObject(memDC,hDISP);
  663.          BitBlt(DC,0,0,tb.bmWidth,tb.bmHeight,memDC,0,0,SRCCOPY);
  664.     if hPal > 0 then SelectPalette(DC,oP,False);
  665.         SelectObject(memDC,oB);
  666.     DeleteDC(memDC);
  667.       end;
  668. end;
  669.  
  670. procedure TClipObj.RedrawSelf(DC:hDC;hWin:HWnd);
  671. var
  672.   pBits:Pointer;
  673.   bi:PBitmapInfo;
  674.   pT:Pointer;
  675.   CR:TRect;
  676.   tb:TBitmap;
  677.   memDC:hDC;
  678.   oB:HBitmap;
  679. begin
  680.     if ((hText=0) and (hDisp=0)) then EXIT;
  681.     if ((hText > 0) and IsPrefText) or
  682.         (hDisp=0) then
  683.     begin
  684.     pT := GlobalLock(hText);
  685.     GetClientRect(hWin,CR);
  686.     SetBkMode(DC,transparent);
  687.     DrawText(DC,pT,-1,CR,DT_Left);
  688.     GlobalUnlock(hText);
  689.     end
  690.     else if hDISP > 0 then
  691.       begin
  692.       GetObject(hDISP,sizeof(TBitmap),@tb);
  693.     memDC:=CreateCompatibleDC(DC);
  694.     oB:=SelectObject(memDC,hDISP);
  695.          BitBlt(DC,0,0,tb.bmWidth,tb.bmHeight,memDC,0,0,SRCCOPY);
  696.         SelectObject(memDC,oB);
  697.     DeleteDC(memDC);
  698.       end;
  699. end;
  700.  
  701. function TClipObj.GetStatus : Word;
  702. begin
  703.     GetStatus := Status;
  704. end;
  705.  
  706. function TClipObj.GetPal : hPalette;
  707. begin
  708.     GetPal := hPal;
  709. end;
  710.  
  711. function TClipObj.GetDIB : THandle;
  712. begin
  713.   GetDIB := hDIB;
  714. end;
  715.  
  716. function TClipObj.GetPICT : THandle;
  717. begin
  718.   GetPICT := hPICT;
  719. end;
  720.  
  721. procedure TClipObj.GetInfo(Info:PChar;Len:Integer);
  722. type
  723.   ORec = Record
  724.     DIBSize:Word;
  725.       Width:Word;
  726.     Height:Word;
  727.     Res:Word;
  728.   end;
  729.   PRec = Record
  730.     Size:Word;
  731.   end;
  732. var
  733.   Size:LongInt;
  734.   H : THandle;
  735.   bi   : PBitmapInfo;
  736.   O    :ORec;
  737.   P    :PRec;
  738.   Buf  :Array[0..100] of Char;
  739.   pMFP :PMetaFilePict;
  740. begin
  741.     fillchar(O,sizeOf(ORec),0);
  742.   fillchar(P,sizeof(PRec),0);
  743.   StrCopy(Info,'');
  744.   H := GetDIB;
  745.   if H <> 0 then
  746.       begin
  747.           bi := GlobalLock(H);
  748.           if bi <> nil then
  749.               begin
  750.               with bi^.bmiHeader, O do
  751.                   if bi <> nil then
  752.                     begin
  753.                     Width := biWidth;
  754.                         Height := biHeight;
  755.                         Res := biBitCount;
  756.                   end;
  757.               GlobalUnlock(hDIB);
  758.               O.DIBSize := GlobalSize(hDIB) div 1024;
  759.                 wvsprintf(Buf,'DIB:%uK %u*%u*%u ',O) ;
  760.             StrCat(Info,Buf);
  761.             end;
  762.       end;
  763.   if hPICT <> 0 then
  764.       begin
  765.          pMFP := GlobalLock(hPICT);
  766.     P.Size := GlobalSize(pMFP^.hMF) div 1024;
  767.     GlobalUnlock(hPICT);
  768.     wvsprintf(Buf,'PICT:%iK',P);
  769.     StrCat(Info,Buf);
  770.       end;
  771.     if hNative <> 0 then
  772.       begin
  773.     P.Size := GlobalSize(hNative) div 1024;
  774.     wvsprintf(Buf,' Native:%iK',P);
  775.       StrCat(Info,Buf);
  776.     end;
  777.   if hText > 0 then
  778.       begin
  779.     P.Size := GlobalSize(hText) ;
  780.     if P.Size > 1024 then
  781.         begin
  782.       P.Size := P.Size div 1024;
  783.         wvsprintf(Buf,'Text:%iK',P);
  784.       end
  785.         else
  786.             wvsprintf(Buf,'Text:%i Bytes',P);
  787.       StrCat(Info,Buf);
  788.     end;
  789. end;
  790.  
  791. procedure TClipObj.SetIsPrefText(Choice:Bool);
  792. begin
  793.     IsPrefText := Choice;
  794. end;
  795. procedure TClipObj.ToggleIsPrefText;
  796. begin
  797.     IsPrefText := not IsPrefText;
  798. end;
  799.  
  800. procedure TClipObj.GetFormats(Buf:PChar);
  801. begin
  802.     if Buf <> nil then
  803.       begin
  804.         if (hDisp>0) and (hText>0) then
  805.         StrCopy(Buf,'*')
  806.     else
  807.         StrCopy(Buf,'');
  808.     end;
  809. end;
  810. {****************************  TClipC  ***************************}
  811. constructor TClipC.Init(ALimit,ADelta:Integer);
  812. begin
  813.     TCollection.Init(ALimit,ADelta);
  814. end;
  815.  
  816. destructor TClipC.Done;
  817. begin
  818.     TCollection.Done;
  819. end;
  820. {********************************   TClipItem  ********************}
  821. constructor TClipItem.Init(NewCHandle:THandle;NewCName:PChar;NewCFormat:Word);
  822. begin
  823.     CHandle := NewCHandle;
  824.   CName :=StrNew(NewCName);
  825.   CFormat := NewCFormat;
  826. end;
  827. destructor TClipItem.Done;
  828. begin
  829.     StrDispose(CName);
  830. end;
  831.  
  832. end.
  833.